{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

-- | This  module initializes a reforwarding service for use by
--   cardano-tracer.  It could [re-] serve the three miniprotocols on
--   a new local socket.  Currently,
--     - it reforwards trace messages to the new socket, optionally
--       filtering trace messages.
--     - it does not (currently) reforward EKG to the new socket.
--     - it creates a new Datapoint store, but the datapoint store is empty.

module Cardano.Tracer.Handlers.ReForwarder
  ( initReForwarder
  ) where

import           Cardano.Logging.Trace
import           Cardano.Logging.Tracer.DataPoint
import qualified Cardano.Logging.Types as Log
import           Cardano.Tracer.Configuration
import           Cardano.Tracer.Handlers.Utils (normalizeNamespace)
import           Cardano.Tracer.MetaTrace
import           Ouroboros.Network.Magic (NetworkMagic (..))
import           Ouroboros.Network.NodeToClient (withIOManager)

import           Control.Exception (SomeException (..))
import           Control.Monad (when)
import qualified Data.Text as Text

import           Trace.Forward.Forwarding
import           Trace.Forward.Utils.ForwardSink (ForwardSink)
import           Trace.Forward.Utils.TraceObject (writeToSink)

-- | Initialize the reforwarding service if configured to be active.
--   Returns
--    - the function by which logging sources report their log messages
--    - the DataPoint tracer (for the data point store associated with
--      the forwarding trace server).
initReForwarder :: TracerConfig
                -> Log.Trace IO TracerTrace
                -> IO ( [Log.TraceObject] -> IO ()
                      , Trace IO DataPoint
                      )
initReForwarder TracerConfig{networkMagic, hasForwarding}
                teTracer = do
  mForwarding <- case hasForwarding of
      Nothing -> pure Nothing
      Just (ConnectTo{}, _, _) ->
          error "initReForwarder:  unsupported mode of operation:  ConnectTo.  Use AcceptAt."
      Just (AcceptAt howToConnect, flattenNS -> mFwdNames, forwConf) -> do
          (fwdsink, dpStore :: DataPointStore) <- withIOManager \iomgr -> do
            traceWith teTracer TracerStartedReforwarder
            initForwarding iomgr forwConf $ initForwardingWith howToConnect
          pure $ Just ( filteredWriteToSink
                          (traceObjectHasPrefixIn mFwdNames)
                          fwdsink
                      , dataPointTracer @IO dpStore
                      )
  let traceDP = case mForwarding of
                  Just (_,tr) -> tr
                  Nothing     -> mempty

  let writesToSink' =
        case mForwarding of
          Just (writeToSink',_) ->
            mapM_ writeToSink'
          _ ->
            const $ return ()

  return (writesToSink', traceDP)
  where
    flattenNS = fmap (map (Text.intercalate "."))

    initForwardingWith initHowToConnect =
      InitForwardingWith
        { initNetworkMagic          = NetworkMagic networkMagic
        , initEKGStore              = Nothing
        , initForwarderMode         = Log.Responder
        , initOnForwardInterruption = Just $ \(SomeException e) ->
            traceWith teTracer (TracerForwardingInterrupted initHowToConnect $ show e)
        , initOnQueueOverflow       = Nothing
        , ..
        }

traceObjectHasPrefixIn :: Maybe [Text.Text] -> Log.TraceObject -> Bool
traceObjectHasPrefixIn mFwdNames (normalizeNamespace . Log.toNamespace -> ns) =
  case mFwdNames of
    Nothing       -> True -- forward everything in this case
    Just fwdNames -> any (`Text.isPrefixOf` ns) fwdNames

filteredWriteToSink :: (Log.TraceObject -> Bool)
                    -> ForwardSink Log.TraceObject
                    -> Log.TraceObject -> IO ()
filteredWriteToSink p fwdsink logObj =
  when (p logObj) $ writeToSink fwdsink logObj
